Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/export1a/clsmerge.cls

Visual Basic class definition | 1999-09-30 | 12.9 KB | 451 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsWordMerge"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'**(CLASS HEADER)*************************************************
'*
'*   Author:  Tmess  EMail: [e-mail]
'*  Purpose:  1.Create New word Document
'*            2.Set the pagesetup and Add text to the document
'*            3.Position and format the text
'*            4.Insert data from a database into the table
'*            5.Save the document
'*            6.Create a new e-mail using outlook
'*            7.Insert the document into an e-mail
'*            8.Send the e-mail
'*            9.Delete the document
'*            10.All errors are logged in a textfile and can be raised in the form
'*
'*  You can use all the above or some
'*
'*  Use this at your own risk. I am not responsible for misuse of this class
'*   Please improve if you want. Let me know
'*
'******************************************************************

Public Enum PageSetups
   Landscape = wdOrientLandscape
   Portrait = wdOrientPortrait
End Enum

Public Enum Alignment
    Center = WdParagraphAlignment.wdAlignParagraphCenter
    Left = WdParagraphAlignment.wdAlignParagraphLeft
    Right = WdParagraphAlignment.wdAlignParagraphRight
    Justify = WdParagraphAlignment.wdAlignParagraphJustify
End Enum

Private m_ProcedureName As String 'Name of current procedure: for error handling
Private m_dbPathName As String 'Path and name of Database
Private m_IsConnected As Boolean 'Is there a connection to database
Private m_NumOfLines As Integer 'Number of blank lines to insert
Private m_StrHyperlink As String 'Name of hyperlink
Private m_Strsubject As String 'Subject of E-mail message
Private m_StrTo As String 'Recipient address
Private m_StrToAdd As String 'Text to add to Word doc
Private m_VarMsgBody As Variant 'Body of e-mail message
Private m_FontSize As Integer 'Font size of StrToAdd
Private m_FontBold As Boolean 'Is strToAdd bold or Not
Private m_ParaAlign As Integer 'StrToAdd alignment SEE ENUM ALIGNMENT
Private m_PageSetup As Integer 'Page setup of Word Doc SEE ENUM PAGESETUPS
Private m_Database As Dao.Database 'DAO database object
Private m_Recordset As Dao.Recordset 'DAO Recordset object
Private m_sql As String 'SQL String passed from client
Private i As Integer 'Used in for next loop

Private wrdApp As Word.Application 'MS Word object
Private wrdDoc As Word.Document 'MS Word Document
Private wrdSelection As Word.Selection 'MS Word Selection
Private strDocName As String 'MS Word document name

'Raised if merge successful
Public Event MergeComplete()
'Raised if merge Unsuccessful
Public Event MergeFailed(errNum As Integer, msgWhy As String)
'Raised if merge document saved successfully
Public Event DocumentSaved()
'Raised if merge document saved Unsuccessfully
Public Event DocumentNotSaved(errNum As Integer, msgWhy As String)
'Raised if document was e-mailed successfully
Public Event MessageSent()
'Raised if document was e-mailed Unsuccessfully
Public Event MessageNotSent(errNum As Integer, msgWhy As String)
'Raised if database connection was successful
Public Event ConnectionSuccessful()
'Raised if database connection was Unsuccessful
Public Event ConnectionNotSuccessful(errNum As Integer, msgWhy As String)
'Raise for unknown errors
Public Event UnknownError(errNum As Integer, msgWhy As String)

Private Sub Class_Initialize()

    Set wrdApp = New Word.Application

    'Set to false if you don't want to see the word doc
    wrdApp.Visible = True
    'Database connection has not been established yet
    m_IsConnected = False
End Sub


Private Sub Class_Terminate()

    wrdApp.Quit
    Set wrdSelection = Nothing
    Set wrdDoc = Nothing
    Set wrdApp = Nothing

End Sub
Public Sub OpenNewDoc()

    Set wrdDoc = wrdApp.Documents.Add
    wrdDoc.Select

    Set wrdSelection = wrdApp.Selection

End Sub

Public Property Let PageSetupDocument(IntPageSetup As Integer)

    m_PageSetup = IntPageSetup
    wrdDoc.PageSetup.Orientation = m_PageSetup

End Property

Public Sub DatabaseToConnect(dbPathAndName As String)
On Error GoTo Err_Handler

    'Check to see if a connection to a database is already opened
    If m_IsConnected Then
        MsgBox "Connection already established. Close the current " & _
         "connection first before opening a new database", vbInformation, _
         "Connection Already Established"
        Exit Sub
    End If

    m_dbPathName = dbPathAndName

    'Check to see if the path and the database exists
    If FileExist(m_dbPathName) = False Then
     MsgBox "File Not Found. Could not Establish Connection", vbCritical, _
            "File Not Found"
        Exit Sub
    End If

    Set m_Database = DBEngine.OpenDatabase(m_dbPathName)
    m_IsConnected = True

Exit Sub

Err_Handler:
        m_ProcedureName = "DatabaseToConnect"
        Call ClsErrorHandler

End Sub
Public Sub DatabaseDisConnect()
    'Close and Release database object from memory
    If m_IsConnected Then
        m_Database.Close
        Set m_Database = Nothing
        m_IsConnected = False
        Exit Sub
    End If

End Sub

Public Property Let InsertLinesInDoc(numOfLines As Integer)

    m_NumOfLines = numOfLines
    InsertLines m_NumOfLines

End Property

Public Sub InsertText(strToAdd As String, IntFontSize As Integer, _
    blBold As Boolean, intParagraphAlign As Integer)

    m_StrToAdd = strToAdd
    m_FontBold = blBold
    m_FontSize = IntFontSize
    m_ParaAlign = intParagraphAlign

    InsertTextIntoDoc

End Sub

Public Property Let InsertHyperlinkAddress(strHyperlink As String)

    m_StrHyperlink = strHyperlink
    InsertHyperlink

End Property

Public Sub InsertTableWithData(strRecordSet As String, _
        Optional RecordSetToUse As Dao.Recordset)
On Error GoTo Error_Handler

 Dim intNumofRows As Integer
 Dim intNumofColumns As Integer
 Dim p As Integer, ColWidth As Integer

    'Check to see if a new connection to the database
     'has been established
    If m_IsConnected Then
        m_sql = strRecordSet
        Set m_Recordset = m_Database.OpenRecordset(m_sql)
    Else
        Set m_Recordset = RecordSetToUse
    End If

    m_Recordset.MoveLast
    m_Recordset.MoveFirst

    intNumofColumns = m_Recordset.Fields.Count
    intNumofRows = m_Recordset.RecordCount

    'Insert a new table with rows according to recordCount plus Column header
    'and the number of columns in the recordset

    wrdDoc.Tables.Add wrdSelection.Range, NumRows:=intNumofRows + 1, _
    NumColumns:=intNumofColumns

    With wrdDoc.Tables(1)
    ' Set the column widths
     For i = 0 To intNumofColumns - 1
     ColWidth = Len(m_Recordset.Fields(i).Name)
        .Columns(i + 1).SetWidth ColWidth * 25, wdAdjustNone
        .Cell(1, i + 1).Range.InsertAfter UCase(m_Recordset.Fields(i).Name)
     Next i

        ' Set the shading on the first row to light gray
        .Rows(1).Cells.Shading.BackgroundPatternColorIndex = wdGray25

        ' Bold the first row
        .Rows(1).Range.Bold = True

        ' Center the text in Cell (1,1)
        .Cell(1, 1).Range.Paragraphs.Alignment = wdAlignParagraphCenter

        ' Fill each row of the table with data
        For i = 1 To intNumofRows
         For p = 1 To intNumofColumns
          FillRow i + 1, p, m_Recordset.Fields(p - 1)
         Next p
         p = 1
         m_Recordset.MoveNext
        Next i
    End With

    RaiseEvent MergeComplete

Exit_Handler:

   'release objects from memory
   If m_IsConnected Then
    m_Recordset.Close
   End If

   Set m_Recordset = Nothing
  Exit Sub

Error_Handler:
    m_ProcedureName = "InsertTableWithData"
    Call ClsErrorHandler
    Resume Exit_Handler

End Sub
Private Sub InsertHyperlink()
    'Inserts a hyperlink

    wrdSelection.Hyperlinks.Add Anchor:=wrdSelection.Range, _
    Address:=m_StrHyperlink

End Sub

Private Sub InsertTextIntoDoc()
    'This routines insert text into the word document and sets the font
    'and alignment

    wrdSelection.ParagraphFormat.Alignment = m_ParaAlign
    wrdSelection.Font.Size = m_FontSize
    wrdSelection.Font.Bold = m_FontBold
    wrdSelection.TypeText m_StrToAdd

End Sub
Private Sub InsertLines(LineNum As Integer)
    Dim iCount As Integer
    'Insert blank lines in Word document
    For iCount = 1 To LineNum
        wrdApp.Selection.TypeParagraph
    Next iCount
End Sub

Private Sub FillRow(Row As Integer, Column, _
                   Text1 As String)
' Insert the data into the specific cell

    With wrdDoc.Tables(1)
        .Cell(Row, Column).Range.InsertAfter Text1
    End With

End Sub
Public Sub printDoc()
    'print out the word doc
    wrdDoc.PrintOut

End Sub
Public Sub SendDoc(ByVal strTo As String, ByVal strSubject As String, _
    varMsgBody As Variant)

On Error GoTo OutLookTrap
    'Mail the word document to recipient specified

Dim ObjOutlook As Outlook.Application
Dim ObjMailItem As Outlook.MailItem


    m_Strsubject = strSubject
    m_StrTo = strTo
    m_VarMsgBody = varMsgBody

    'Check to see if the e-mail address is correct by checking the format
    If checkEmailAddress = False Then
     m_ProcedureName = "SendDoc"
     Call ClsErrorHandler
     Exit Sub
    End If

        Set ObjOutlook = New Outlook.Application
        Set ObjMailItem = ObjOutlook.CreateItem(olMailItem)

    'create e-mail and insert attachment
        With ObjMailItem
            .Recipients.Add m_StrTo
            .Subject = m_Strsubject
            .Body = m_VarMsgBody & vbCrLf & vbCrLf
            .Attachments.Add strDocName
        End With

        ObjMailItem.Send
        RaiseEvent MessageSent

OutLookTrapExit:
        Set ObjMailItem = Nothing
        Set ObjOutlook = Nothing
        Exit Sub
OutLookTrap:
        m_ProcedureName = "SendDoc"
        Resume OutLookTrapExit
End Sub
Public Sub SaveDocAsAndClose(Path As String, StrToSaveAs As String)
On Error GoTo Err_Handler
    'Check to see if the path exists
    If DriveExist(Path) = False Then Exit Sub

    ' Save the document, close it
    strDocName = Path & StrToSaveAs & ".doc"
    wrdDoc.SaveAs strDocName
    wrdDoc.Close

    RaiseEvent DocumentSaved

Exit_Err_Handler:
   Exit Sub

Err_Handler:
    m_ProcedureName = "SaveDocAsAndClose"
    Resume Exit_Err_Handler

End Sub

Public Sub DeleteDoc(PathAndDocName As String)
   'Delete a file
   If FileExist(PathAndDocName) Then
    Kill PathAndDocName
   End If

End Sub
Public Sub InsertCurrentDate()
    'Inserts the current date with the deafult font

    wrdSelection.InsertDateTime _
    DateTimeFormat:="dddd, MMMM dd, yyyy", InsertAsField:=False

End Sub

Private Function checkEmailAddress() As Boolean
On Error Resume Next
    'parses e-mail address to see if is correct
    i = InStr(m_StrTo, "@")
    checkEmailAddress = (InStr(i + 1, m_StrTo, ".") > 0)

End Function

Private Function FileExist(filename As String) As Boolean
On Error Resume Next

    FileExist = (Dir$(UCase((filename))) <> "")

End Function

Private Function DriveExist(Path As String) As Boolean
On Error Resume Next

    DriveExist = (Dir(UCase((Path))) <> "")

End Function

Private Sub ClsErrorHandler()
    'Generic Error handling routine

Dim handleErr As String
Dim textfile As String

    'Raise the event according the procedure passed. Will write all errors
     'to an error log. Errors on the form will only be visible if
     'the event is active and a debug.print statement or message box
     'is inserted

Select Case m_ProcedureName

    Case Is = "SaveDocAsAndClose"
        RaiseEvent DocumentNotSaved(Err.Number, Err.Description)

    Case Is = "SendDoc"
        RaiseEvent MessageNotSent(Err.Number, Err.Description)

    Case Is = "InsertTableWithData"
        RaiseEvent MergeFailed(Err.Number, Err.Description)

    Case Is = "DatabaseToConnect"
        RaiseEvent ConnectionNotSuccessful(Err.Number, Err.Description)

    Case Else
        RaiseEvent UnknownError(Err.Number, Err.Description)

End Select

    'Log the errors to an error log
    textfile = App.Path & "\ErrogLog.txt"
    handleErr = "Error: " & Err.Number & " " & Err.Description & _
                 " " & Err.Source

    Open textfile For Append As #1 'write error to textfile
        Write #1, Now; handleErr; m_ProcedureName
    Close #1

    Err.Clear

End Sub